\ More standard words for noForth RV
\ (C) 2015, Albert Nijhof & Willem Ouwerkerk
\ updated juni 2020

v: fresh inside also       \ some definitions use inside words

\ trivia
: 0>    ( n -- flag )   0 > ;
: D-    ( dn1 dn2 -- dn3 )      dnegate d+ ;
: M+    ( d n -- d )    s>d d+ ;
: CHAR+ ( n1 -- n2 )    1+ ;
: CHAR- ( n1 -- n2 )    1- ;
: CHARS ( n -- n )  ; IMMEDIATE
: ERASE     ( a n -- )  0 fill ;
: UNUSED    ( -- n )    border chere - ;

create PAD  ( -- a )    20 allot        \ example

: SOURCE    ib #ib ;
: SAVE-INPUT    ( -- ib #ib^>in@ source-id )  @input 3 ;
: RESTORE-INPUT ( ib #ib^>in@ source-id 3 -- )    3 ?pair !input ;
: WORD ( ch -- a )
    >r   parea r@ skip   nip ib - >in !
    r>   parse    >fhere ;


(*
    : 2!    ( lo hi a -- )  tuck ! cell+ ! ;
    : 2@    ( a -- lo hi )  dup cell+ @ swap @ ;
    code 2! ( lo hi a -- )
        day 4 sp x) .mov                \ lo
        sun sp ) .mov   tos ) sun .mov  \ !hi
        4 tos x) day .mov               \ !lo
        tos 8 sp x) .mov   sp 0C .addi
    next end-code
    code 2@ ( a -- lo hi )
        day 4 tos x) .mov       \ @lo
        tos tos ) .mov          \ hi
        sp -) day .mov          \ lo
    next end-code
*)
hex
code 2! ( lo hi a -- )
    40D4 h, 4098 h, C018 h, C054 h,
    4480 h, 4B1 h, 8382 h,
  next  end-code
code 2@ ( a -- lo hi )
    4054 h, 4000 h, 14F1 h, C094 h,
    8382 h, next  end-code

: [COMPILE]     ' ?comp compile, ; immediate

header ABORT"   ' S" @ ,   reveal immediate
:noname if  inls count cr type -2 throw
        then inls drop ; drop

: RECURSE       ( -- )
    ?comp s0 @ dup if , exit then
    1- ?abort ; immediate

: ROLL  ( i*x u -- j*x )
    dup 1 <
    if drop
    else  swap >r 1- RECURSE r> swap
    then ;

\ symmetric signed division
: SM/REM    ( dn n -- rest quot )
    over >r >r   dabs r@ abs um/mod
    r> r@ xor ?negate swap   r> ?negate swap ;
: /REM  ( x1 x2 -- r q )    >r s>d r> sm/rem ;

0
v: true or
    [if]
only forth 1  constant FORTH-WORDLIST fresh inside
: GET-CURRENT   v0 c@ ;
: SET-CURRENT   v0 c! ;
: GET-ORDER     ( -- wids.. n )
    v0
    dup vp - dup >r                     \ n v0 n
    0 ?do   1- dup c@ swap loop drop r> ;
: SET-ORDER     ( wids.. n -- )
    dup -1 = if drop 0 1 3 1 4 then     \ fresh
    8 over u< ?abort                    \ overflow
    v0 over - to vp
    vp swap 0
   ?do tuck c! 1+ loop drop ;

: SEARCH-WORDLIST   ( adr len wid -- 0 | xt 1 | xt -1 )
    >r
    >fhere
    v0 cell+   dup 1-
    r> over c!      \ mini search-order with 1 wid
    find)
    dup ?exit nip ;
[then]

: THENS         \ close open IFs
    begin postpone then dup 11 <> until ; immediate

\ the never dying CASE
: OF?   over = ;
: CASE  hx 88 ; immediate
: OF    postpone of? postpone if postpone drop ; immediate
: ENDOF     postpone else ; immediate
: ENDCASE   ( x -- )
   postpone drop
   begin postpone then hx 88 of?
   until drop ; immediate

v: FRESH

\ <><>
